home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / HippoDraw / hippo / hb2hippo.f < prev    next >
Encoding:
Text File  |  1992-04-28  |  11.6 KB  |  446 lines
  1.       Program hb2hippo
  2. C     ----------------
  3. C
  4. C        Conversion of HBOOK4 data to Hippo data
  5. C        By Paul Kunz, SLAC, August 1990
  6. C
  7. C        This is main program that parses command line arguments
  8. C    
  9. C    $Id: hb2hippo.f,v 1.4 1992/02/02 14:23:40 pfkeb Rel $
  10. C
  11. C    Compiled and tested on...
  12. C    AIX 3.1, IBM FORTRAN 2.1
  13. C    NeXT 2.1, Absoft FORTRAN 3.1
  14. C    NeXT 2.1, f2c Oct 15, 1991 (but not tested)
  15. C    SunOS 4.0.3, Sun FORTRAN 1.2
  16. C
  17. C      Implicit none
  18. C
  19. C       External functions...
  20.       Integer hb2copen
  21.       Integer iargc
  22. C
  23. C    Standard UNIX codes...
  24.       Integer    EXIT_SUCCESS,     EXIT_FAILURE
  25.       Parameter( EXIT_SUCCESS = 0, EXIT_FAILURE = 1 )
  26.       Integer    FILENAME_MAX
  27.       Parameter( FILENAME_MAX = 1024 )
  28. C others      Parameter( FILENAME_MAX = 255 )
  29. C      
  30.       Character*(FILENAME_MAX)  hbfn
  31.       Character*(FILENAME_MAX)  hifn
  32.       Integer nargs
  33.       Integer irc
  34. C
  35.       nargs = iargc()
  36. C
  37.       if ( nargs .lt. 1  .or.  nargs .ge. 3 ) then
  38.          Print *, 'Useage: hb2hippo hbook_file hippo_file'
  39.          irc = EXIT_FAILURE
  40.          Go to 100
  41.       Elseif ( nargs .eq. 1 ) then
  42.          Call getarg( 1, hbfn )
  43.          hifn = 'out.hippo'
  44.       Elseif ( nargs .eq. 2 ) then
  45.          call getarg( 1, hbfn )
  46.          call getarg( 2, hifn )
  47.       Endif
  48.          
  49.       irc = hb2copen( hbfn, hifn )
  50.       
  51.   100 Continue
  52.       End
  53.  
  54.       Integer Function hb2cdir(dirname)
  55. C     ---------------------------------
  56. C      
  57. C        Conversion of HBOOK4 data to Hippo data
  58. C        By Paul Kunz, SLAC, August 1990
  59. C
  60. C        This routine reads the HBOOK directory and steers the work
  61. C
  62. C         Implicit none
  63.       
  64.       Character *(*) dirname
  65. C
  66. C    Standard UNIX exit codes
  67.       Integer EXIT_SUCCESS, EXIT_FAILURE
  68.       Parameter( EXIT_SUCCESS = 0, EXIT_FAILURE = 1 ) 
  69. C      
  70. C    External functions...
  71.       Integer hb2c1d, hb2c2d, hb2cnt
  72. C
  73.       Character*1 CHANGE_CWD
  74.       Parameter(  CHANGE_CWD = ' ')
  75.       Integer     ALL_IDS
  76.       Parameter(  ALL_IDS = 0 )
  77. C      
  78.       Integer id, ih, nid    
  79.       Integer    MAXVEC
  80.       Parameter( MAXVEC = 100 )
  81.       Integer idvec(MAXVEC)    
  82. C      
  83.       Integer idim, iofset, icycle
  84.       Character*80 tdir
  85.       Character*10 tname
  86. C      
  87.       tdir = "//dummy/"//dirname
  88. C    go to subdirectory      
  89.       Call hcdir( tdir, CHANGE_CWD )    
  90. C    just to check its there      
  91.       Call hldir( ' ', 'T')    
  92.       iofset = 0
  93.       icycle = 9999
  94. C    read in all the histos      
  95.       Call hrin(ALL_IDS, icycle, iofset) 
  96. C      
  97. C        Do 1D and 2D histograms...
  98. C
  99.       Do  idim = 1, 2    
  100.      If ( idim .eq. 1 ) Call hid1( idvec, nid )
  101.      If ( idim .eq. 2 ) Call hid2( idvec, nid )
  102.      If ( nid .gt. MAXVEC ) then
  103.         Write(*,6000) dirname, nid, idim, MAXVEC
  104.  6000          Format(
  105.      +         " Directory ", A, " has ", I4, I2, "D histograms," /
  106.      +         " while hb2cdir compiled for", I4, " histograms."/
  107.      +         " An array overflow has thus occured, job aborting.")
  108.         hb2cdir = EXIT_FAILURE
  109.         Return
  110.      endif
  111. C
  112.      Do ih = 1, nid
  113.         id = idvec(ih)
  114.         If ( idim .eq. 1 ) hb2cdir = hb2c1d( id )    
  115.         If ( idim .eq. 2 ) hb2cdir = hb2c2d( id )    
  116.         If ( hb2cdir .eq. EXIT_SUCCESS ) then
  117.         Write(tname, 6010)  id, '.histo'
  118.  6010         format( I4.4, A6)
  119. C            histograms not handled currently
  120. C            Here is where the code would go to add histograms
  121. C            to the display list
  122.         endif
  123. C
  124.          End do 
  125.       End Do 
  126. C
  127. C        Do n-tuples...
  128. C      
  129.       Call hidall( idvec, nid)
  130.       If ( nid .gt. MAXVEC ) then
  131.      Write(*,6000) dirname, nid, MAXVEC
  132.  6020    Format(
  133.      +   " Directory ", A, " has ", I4, I2, "histograms," /
  134.      +   " while hb2cdir compiled for", I4, " histograms."/
  135.      +   " An array overflow has thus occured, job aborting.")
  136.      hb2cdir = EXIT_FAILURE
  137.      Return
  138.       endif
  139. C
  140.       Do ih = 1, nid
  141.      id = idvec(ih)
  142.      hb2cdir = hb2cnt(dirname, id)    
  143.       End do 
  144. C
  145. C        All done
  146. C      
  147.       Call hdelet(ALL_IDS)    
  148.       hb2cdir = EXIT_SUCCESS
  149.       Return 
  150.       end
  151.       
  152.       Integer Function hb2cnt(dirname, id)
  153. C     ------------------------------------      
  154. C      
  155. C        Conversion of HBOOK4 data to Hippo data
  156. C        By Paul Kunz, SLAC, June 1991
  157. C
  158. C        This routine converts n-tuple to Hippo file
  159. C
  160. C          Implicit none
  161. C
  162.       Character *(*) dirname
  163.       Integer id
  164.  
  165. C
  166. C    hippo functions used...
  167.       Integer ipnew, ipsetnttitle, ipsetntlabel, iparrayfill
  168. C
  169.       Integer         nt, ntlist, NNTLIST
  170.       Parameter(                  NNTLIST = 100 )
  171.       Common /hippoc/ nt, ntlist(NNTLIST)
  172. C
  173. C    Standard UNIX exit codes
  174.       Integer    EXIT_SUCCESS,     EXIT_FAILURE
  175.       Parameter( EXIT_SUCCESS = 0, EXIT_FAILURE = 1 ) 
  176. C      
  177.       Character*1 CHANGE_CWD
  178.       Parameter(  CHANGE_CWD = ' ')
  179.       Integer     ALL_IDS
  180.       Parameter(  ALL_IDS = 0 )
  181. C      
  182. C    N-tuple information returned by HGIVEN...
  183.       Character*80 tname
  184.       Integer     NVARS
  185.       Parameter ( NVARS = 100)      
  186.       Character*8 tags(NVARS)     
  187.       Real xlow(NVARS), xhigh(NVARS) 
  188.       Real x(NVARS)                  
  189. C      
  190.       Integer     ie, iv
  191.       Integer     ninout, numvars, ierror
  192.       Integer     nidn    
  193. C      
  194.       Integer ntuple        
  195.       Integer irc
  196. C      
  197. C    Careful: ninout is in and out variable
  198.       ninout = NVARS        
  199.       Call hgiven( id, tname, ninout, tags, xlow, xhigh )
  200.       numvars = ninout
  201.       If ( numvars .eq. 0 ) then
  202.       hb2cnt = EXIT_FAILURE
  203.           Return
  204.       Endif
  205. C
  206.       ntuple = ipnew( numvars)
  207.       irc = ipsetNtTitle( ntuple, tname )      
  208. C
  209.       Do iv = 1, numvars
  210.          irc = ipsetNtLabel( ntuple, iv, tags(iv) )
  211.       End do 
  212. C      
  213.       nidn = 0
  214.       ie = 0
  215.    10 Continue
  216.       ie = ie + 1
  217.       Call hgn( id, nidn,  ie, x, ierror )
  218. C    exit if end of file     
  219.       If ( ierror .lt. 0 ) Go to 100
  220.       irc = iparrayFill( ntuple, x )
  221.       Go to 10
  222.   100 Continue
  223. C
  224.       nt = nt + 1
  225.       If ( nt .lt. NNTLIST ) then
  226.          ntlist(nt) = ntuple
  227.       Else
  228.          irc = NNTLIST -1
  229.          Print *, "hb2hippo compiled for only", irc, "hippo ntuples."
  230.          Print *, "This HBOOK ntuple ignored."
  231.          Print *, "Recompile hb2hippo.f with larger NNTLIST parameter."
  232.       Endif
  233. C     
  234.       hb2cnt = EXIT_SUCCESS
  235.       Return 
  236.       end
  237.  
  238.       Integer Function hb2copen( inname, outname)
  239. C     ---------------------------------------------
  240. C      
  241. C        Conversion of HBOOK4 data to Hippo data
  242. C        By Paul Kunz, SLAC, August 1990
  243. C
  244. C        This routine reads the HBOOK file directory
  245. C
  246. C         Implicit none
  247.  
  248.       Character *(*) inname           
  249.       Character *(*) outname            
  250. C      
  251. C    Standard UNIX exit codes
  252.       Integer    EXIT_SUCCESS,     EXIT_FAILURE
  253.       Parameter( EXIT_SUCCESS = 0, EXIT_FAILURE = 1 )
  254. C
  255. C       External functions...
  256.       Integer hb2cdir    
  257.       Integer ipwrite   
  258. C
  259.       Integer         nt, ntlist, NNTLIST
  260.       Parameter(                  NNTLIST = 100 )
  261.       Common /hippoc/ nt, ntlist(NNTLIST)
  262. C
  263. C    no way to know NWPAW ahead of time
  264.       Integer    NWPAW
  265.       Parameter( NWPAW = 500000)    
  266.       Real          h
  267.       common /pawc/ h(NWPAW)
  268. C
  269. C    error codes for RZ package
  270.       Integer        iquest
  271.       common /quest/ iquest(100)    
  272. C      
  273.       Integer    MAXDIR, idir, ndir
  274.       Parameter( MAXDIR = 10 )        
  275.       Character*80 dirname(MAXDIR)
  276. C      
  277.       Integer    LREC, irc, istat
  278. C    recommended record lenght to HROPEN      
  279.       Parameter (LREC = 1024)    
  280. C      
  281. C
  282.       Print *, " HBOOK4 to Hippo converter" 
  283. C      Print *, " Converting file: ", inname
  284. C      Print *, " to output file:  ", outname
  285. C
  286. C    initialize Hippo
  287.       nt = 0            
  288. C    initialize HBOOK and ZEBRA
  289.       Call hlimit(NWPAW)        
  290. C      
  291.       Call hropen( 1, 'dummy', inname, ' ', LREC, istat )
  292.       If ( istat .ne. 0 ) then
  293.          Print *, " Failure to open file: ", inname
  294.      hb2copen = EXIT_FAILURE
  295.      Return
  296.       Endif
  297. C         
  298.       Do idir = 1, MAXDIR
  299. C        avoid trailing x00      
  300.          dirname(idir) = ' '    
  301.       End do
  302. C
  303. C    find subdirectories
  304.       Call rzrdir(MAXDIR, dirname, ndir ) 
  305.       If ( iquest(1) .ne. 0 ) then
  306.          Print *, " There are ", iquest(11), " directories,"
  307.      Print *, " while hb2hippo was compiled for", ndir, 
  308.      +            " directories."
  309.          Print *, " Only the first ", ndir,
  310.      +                 " directories processed."
  311.       Endif
  312. C
  313. C    handle case of no directories
  314.       if ( ndir .le. 0 ) ndir = 1    
  315.       Do idir = 1, ndir
  316.      hb2copen = hb2cdir( dirname(idir) )    
  317.      If ( hb2copen .ne. EXIT_SUCCESS ) Return
  318.       End do
  319. C
  320.       if ( nt .lt. NNTLIST ) then
  321.          nt = nt + 1
  322.       else
  323.          irc = NNTLIST -1
  324.          Print *, "There are", nt, "HBOOK ntuples while,"
  325.          Print *, "hb2hippo compiled for only", irc, "hippo ntuples."
  326.          Print *, "Recompile hb2hippo.f with larger NNTLIST parameter."
  327.          nt = NNTLIST
  328.       endif
  329. C
  330.       ntlist(nt) = 0
  331.       irc = ipwrite( outname, 0, ntlist )
  332. C
  333.       hb2copen = EXIT_SUCCESS
  334.       Return 
  335.       end
  336.  
  337.       Integer Function hb2c1d(id)
  338. C     ---------------------------
  339. C      
  340. C        Conversion of HBOOK4 data to Hippo data
  341. C        By Paul Kunz, SLAC, June 1991
  342. C
  343. C        This routine processes 1D histogram id
  344. C
  345. C     Implicit none
  346.       Integer id
  347. C      
  348. C    External functions..
  349.       Real   hi
  350. C
  351. C    Standard UNIX exit codes
  352.       Integer EXIT_SUCCESS, EXIT_FAILURE
  353.       Parameter( EXIT_SUCCESS = 0, EXIT_FAILURE = 1 ) 
  354. C      
  355. C    This Common block holds results of HGIVE
  356.       Integer nx, ny, nwt, loc
  357.       Real*4 xmi, xma, ymi, yma
  358.       Character*80 chtitl
  359.       Common /give/ chtitl, nx, xmi, xma, ny, ymi, yma, nwt, loc
  360. C      
  361.       Integer    MXSIZE
  362.       Parameter( MXSIZE = 1000 )
  363.       Real*4 conten
  364.       common /unpak/ conten(0:(MXSIZE+2)*(MXSIZE+2) )
  365.  
  366.       Real*4 xwidth
  367.       
  368.       hb2c1d = EXIT_FAILURE
  369.       Call hgive ( id, chtitl, nx, xmi, xma,
  370.      +                         ny, ymi, yma, nwt, loc)
  371.       If ( nx .eq. 0 ) Return
  372.       If ( nx .gt. MXSIZE*MXSIZE ) then
  373.           Print *, " Too many bins, histogram ignored"
  374.          Return
  375.       endif
  376. C      
  377.       xwidth = (xma - xmi) / nx
  378. C        histograms are not handled currently
  379. C        Here is where to put the code to create new display
  380.       Call hunpak( id, conten(1), 'HIST', 1 )
  381.       conten(0)    = hi( id, 0 )
  382.       conten(nx+1) = hi( id, nx+1)
  383. C        Here is where to put the code to fill the bins
  384.       hb2c1d = EXIT_SUCCESS
  385.       Return 
  386.       end
  387.  
  388.       Integer Function hb2c2d(id)
  389. C     ---------------------------      
  390. C      
  391. C        Conversion of HBOOK4 data to Hippo data
  392. C        By Paul Kunz, SLAC, June 1991
  393. C
  394. C        This routine processes 2D histogram id
  395. C
  396. C      Implicit none
  397. C      
  398.       Integer id
  399. C      
  400. C    Standard UNIX exit codes
  401.       Integer    EXIT_SUCCESS,     EXIT_FAILURE
  402.       Parameter( EXIT_SUCCESS = 0, EXIT_FAILURE = 1 ) 
  403. C      
  404. C    External Functions...
  405.       Real hij    
  406.  
  407. C    This Common block holds results of HGIVE
  408.       Integer       nx, ny, nwt, loc
  409.       Real          xmi, xma, ymi, yma
  410.       Character*80  chtitl
  411.       Common /give/ chtitl, nx, xmi, xma, ny, ymi, yma, nwt, loc
  412. C
  413. C    This Common block holds the results of HUNPAK
  414.       integer   MXSIZE
  415.       Parameter(MXSIZE=1000)
  416.       Real           conten
  417.       common /unpak/ conten(0:(MXSIZE+2)*(MXSIZE+2) )
  418.  
  419.       Real xwidth, ywidth
  420.       Integer i, ix, iy, ntotal
  421.       
  422.       hb2c2d = EXIT_FAILURE
  423.       Call hgive ( id, chtitl, nx, xmi, xma,
  424.      +                         ny, ymi, yma, nwt, loc)
  425.       If ( nx .eq. 0  .or.
  426.      +     ny .eq. 0        ) Return
  427.       If ( nx .gt. MXSIZE .or.
  428.      +     ny .gt. MXSIZE      ) then
  429.          Print *, " Too many bins, histogram id", id, " ignored"
  430.          Return
  431.       endif
  432.       xwidth = (xma - xmi) / nx
  433.       ywidth = (yma - ymi) / ny
  434. C        Here is where to put the code to create new display
  435.       i = 0            
  436.       Do 150 iy = 0, ny+1
  437.      Do 150 ix = 0, nx + 1
  438.         conten(i) = hij( id, ix, iy)
  439.         i = i + 1
  440.   150 Continue        
  441.       ntotal = (nx+2)*(ny+2) 
  442. C        Here is where to put the code to fill the bins 
  443.       hb2c2d = EXIT_SUCCESS
  444.       Return
  445.       end
  446.